
import Debug.QuickCheck
import Text.Show.Functions

import Data.Char
import Data.Maybe
import Data.List

---------------------------------------------------------------------
-- 1.

length' :: [a] -> Int
length' xs = sum (map (\x -> 1) xs)

--

addUp  ns = filter (>1) (map (+1) ns)
addUp' ns = map (+1) (filter (>0) ns)

prop_AddUp ns = addUp' ns == addUp (ns :: [Int])

--

iter :: Int -> (a -> a) -> (a -> a)
iter 0 f = id
iter n f = f . iter (n-1) f

{-
-- alternatively:
iter :: Int -> (a -> a) -> (a -> a)
iter 0 f x = x
iter n f x = f (iter (n-1) f x)
-}

--

mystery xs = foldr (++) [] (map sing xs)
 where
  sing x = [x]

prop_Mystery xs = mystery xs == (xs :: [Int])

--

dropUntil :: (a -> Bool) -> [a] -> [a]
dropUntil p []                 = []
dropUntil p (x:xs) | p x       = x:xs
                   | otherwise = dropUntil p xs

prop_DropUntil p xs =
  dropUntil p xs == dropWhile (not . p) (xs :: [Int])

--

getUntil p = takeWhile (not . p)

--

dropSpace = dropUntil (not . isSpace)

--takeWhile p = getUntil (not . p)

--

lines' [] = []
lines' xs = getUntil (=='\n') xs : lines' (drop 1 (dropUntil (=='\n') xs))

instance Arbitrary Char where
  arbitrary =
    oneof
    [ choose ('a','z')
    , elements " \n\t"
    ]

prop_Lines xs = lines' xs == lines xs

-- 10

{-
(id . f)  is the same as f, because the result of f is fed to the
          identity function id, and thus not changed
(id :: Bool -> Bool)

(f . id)  is the same as f, because the argument of f is fed to the
          identity function id, and thus not changed
(id :: Int -> Int)

id f      is the same as f, because applying id to something does not
          change it
(id :: (Int -> Bool) -> (Int -> Bool))
-}

--

composeList :: [a -> a] -> (a -> a)
composeList = foldr (.) id

{-
-- alternatively
composeList :: [a -> a] -> (a -> a)
composeList []     = id
composeList (f:fs) = f . composeList fs
-}

--

prop_IterN x y =
  x >= 0 && y >= 0 ==>
    f1 x y == f2 x y
 where
  f1 = (\n -> iter n succ) :: Int -> Int -> Int
  f2 = (+)

--

{-
\x y -> f y x
-}

--

flip' :: (a -> b -> c) -> (b -> a -> c)
flip' f = \x y -> f y x

---------------------------------------------------------------------
-- 2.

solve :: (Double -> Double) -> (Double,Double) -> Double
solve f (x0,x1)
  | fx =? 0            = x
  | x0 == x1           = error "no solution found!"
  | fx0 > 0 || fx1 < 0 = error "interval does not contain 0!"
  | fx < 0             = solve f (x,x1)
  | fx > 0             = solve f (x0,x)
 where
  x   = (x0 + x1) / 2
  fx  = f x
  fx0 = f x0
  fx1 = f x1
  
  x =? y = abs (x-y) < 0.0000000001

---------------------------------------------------------------------
-- 3.

prop_A1  xs    = map (+1) xs                                       == [ x+1 | x <- xs :: [Int] ]
prop_A2  xs ys = concat (map (\x -> map (\y -> x+y) ys) xs)        == [ x+y | x <- xs, y <- ys :: [Int] ]
prop_A3  xs    = map (+2) (filter (>3) xs)                         == [ x+2 | x <- xs :: [Int], x > 3 ]
prop_A4  xys   = map (\(x,_) -> x+3) xys                           == [ x+3 | (x,_) <- xys :: [(Int,Int)] ]
prop_A4' xys   = map ((+3) . fst) xys                              == [ x+3 | (x,_) <- xys :: [(Int,Int)] ]
prop_A5  xys   = map ((+4) . fst) (filter (\(x,y) -> x+y < 5) xys) == [ x+4 | (x,y) <- xys :: [(Int,Int)], x+y < 5 ]
prop_A6  mxs   = map (\(Just x) -> x+5) (filter isJust mxs)        == [ x+5 | Just x <- mxs :: [Maybe Int] ] 

prop_B1  xs    = [ x+3 | x <- xs ]               == map (+3) (xs :: [Int])
prop_B2  xs    = [ x | x <- xs, x > 7 ]          == filter (>7) (xs :: [Int])
prop_B3  xs ys = [ (x,y) | x <- xs, y <- ys ]    == concat (map (\x -> map (\y -> (x,y)) (ys :: [Int])) (xs :: [Int]))
prop_B4  xys   = [ x+y | (x,y) <- xys, x+y > 3 ] == filter (>3) (map (\(x,y) -> x+y) (xys :: [(Int,Int)])) 

instance Arbitrary a => Arbitrary (Maybe a) where
  arbitrary =
    frequency
    [ (1, do return Nothing)
    , (5, do x <- arbitrary
             return (Just x))
    ]

---------------------------------------------------------------------
-- 4.

build :: Ord a => [(a,b)] -> Table a b
build xys = table (length xys') xys'
 where
  xys' = sortBy first' xys                  -- bug!
  --xys' = nubBy first (sortBy first' xys)  -- correct

  (x1,_) `first`  (x2,_) = x1 == x2
  (x1,_) `first'` (x2,_) = x1 `compare` x2

  table _ []  = Empty
  table n xys = Join (table k lefts) x y (table (n-k-1) rights)
   where
    k      = n `div` 2
    lefts  = take k xys
    rights = drop (k+1) xys
    (x,y)  = xys !! k

prop_Build_Invariant xys =
  invariant (build (xys :: [(Int,Double)]))
    
prop_Build_Complete xys =
  and [ (x,y) `elem` (xys :: [(Int,Double)]) | (x,y) <- contents (build xys) ]
    
prop_Build_Enough xys =
  and [ x `elem` map fst (contents (build xys)) | (x,_) <- xys :: [(Int,Double)] ]
    
invariant :: Ord a => Table a b -> Bool
invariant Empty          = True
invariant (Join l x y r) =
  l <. x && x .< r && invariant l && invariant r
 where
  Empty         <. x = True
  Join _ x' _ _ <. x = x' < x

  x .< Empty         = True
  x .< Join _ x' _ _ = x < x'

--

data Table a b
  = Empty
  | Join (Table a b) a b (Table a b)
 deriving ( Eq, Show )

contents :: Table a b -> [(a,b)]
contents Empty          = []
contents (Join l x y r) = contents l ++ [(x,y)] ++ contents r

---------------------------------------------------------------------
-- 5.

{-
For 3 elements it takes 6 steps.
For n elements, it takes some quadratic function number of steps.
-}

--

revApp :: [a] -> [a] -> [a]
revApp []     ys = ys
revApp (x:xs) ys = revApp xs (x:ys)

prop_RevApp xs ys =
  revApp xs ys == reverse xs ++ (ys :: [Int])

--

{-
For n,m elements, it takes n steps (independent of m).
-}

--

reverse' :: [a] -> [a]
reverse' xs = revApp xs []

--

{-
For n elements, it takes n steps.
-}

---------------------------------------------------------------------
-- 6.

data Set a = Set [a]
 deriving ( Show )
 
empty :: Set a
empty = Set []

add :: Eq a => a -> Set a -> Set a
add x (Set xs) | x `elem` xs = Set xs
               | otherwise   = Set (x:xs)

remove :: Eq a => a -> Set a -> Set a
remove x (Set xs) = Set (xs \\ [x])

combine :: Eq a => Set a -> Set a -> Set a
Set xs `combine` Set ys = Set (xs ++ ys)   -- bug!
--Set xs `combine` Set ys = Set (xs `union` ys) -- correct

member :: Eq a => a -> Set a -> Bool
member x (Set xs) = x `elem` xs

isEmpty :: Set a -> Bool
isEmpty (Set xs) = null xs

--

instance (Arbitrary a, Eq a) => Arbitrary (Set a) where
  arbitrary =
    do xs <- arbitrary
       return (Set (nub xs))

-- set invariant      
inv :: Set Int -> Bool
inv (Set xs) = nub xs == xs

-- set contents     
conts :: Set Int -> [Int]
conts (Set xs) = xs

-- helper function:
-- xs =*= ys checks if the lists xs and ys contain the same elements,
-- disregarding the number of times these elements occur
(=*=) :: [Int] -> [Int] -> Bool
xs =*= ys = sort (nub xs) == sort (nub ys)

prop_Empty =
  conts empty =*= []
  
prop_Add x s =
  conts (add x s) =*= (x : conts s)
  
prop_Remove x s =
  conts (remove x s) =*= (conts s \\ [x])
  
prop_Combine s1 s2 =
  conts (s1 `combine` s2) =*= (conts s1 ++ conts s2)
  
prop_Member x s =
  member x s == elem x (conts s)
  
prop_IsEmpty s =
  isEmpty s == null (conts s)

--

prop_Inv s =
  inv s

prop_Empty_Inv =
  inv empty
  
prop_Add_Inv x s =
  inv (add x s)
  
prop_Remove_Inv x s =
  inv (remove x s)  

prop_Combine_Inv s1 s2 =
  inv (s1 `combine` s2)  

---------------------------------------------------------------------
-- 7.

{-
data Set a = Set [a]
 deriving ( Show )
 
empty :: Set a
empty = Set []

add :: Ord a => a -> Set a -> Set a
add x (Set xs) | x `elem` xs = Set xs
               | otherwise   = Set (insert x xs)

remove :: Eq a => a -> Set a -> Set a
remove x (Set xs) = Set (xs \\ [x])

combine :: Ord a => Set a -> Set a -> Set a
Set xs `combine` Set ys = Set (xs `merge` ys)
 where
  [] `merge` ys = ys
  xs `merge` [] = xs
  (x:xs) `merge` (y:ys)
    | x < y     = x : (xs `merge` (y:ys))
    | x == y    = x : (xs `merge` ys)
    | otherwise = y : ((x:xs) `merge` ys)

member :: Eq a => a -> Set a -> Bool
member x (Set xs) = x `elem` xs

isEmpty :: Set a -> Bool
isEmpty (Set xs) = null xs

--

instance (Arbitrary a, Ord a) => Arbitrary (Set a) where
  arbitrary =
    do xs <- arbitrary
       return (Set (sort (nub xs)))

-- set invariant      
inv :: Set Int -> Bool
inv (Set xs) = nub xs == xs && sort xs == xs

-- set contents     
conts :: Set Int -> [Int]
conts (Set xs) = xs

-- the rest stays the same!
-}

---------------------------------------------------------------------
-- 8.

{-
data Set a
  = Nil
  | Comb (Set a) a (Set a)
 deriving ( Show )

empty :: Set a
empty = Nil

add :: Ord a => a -> Set a -> Set a
add x Nil     = Comb Nil x Nil
add x (Comb l y r)
  | x < y     = Comb (add x l) y r
  | x == y    = Comb l y r
  | otherwise = Comb l y (add x r)

remove :: Ord  a => a -> Set a -> Set a
remove x Nil  = Nil
remove x (Comb l y r)
  | x < y     = Comb (remove x l) y r
  | x == y    = l `combine` r
  | otherwise = Comb l y (remove x r)

-- there are many choices here... this is a very simple
-- and not very efficient combine function
combine :: Ord a => Set a -> Set a -> Set a
s1 `combine` s2 = comb [s1,s2]
 where
  comb []                = Nil
  comb (Nil : ss)        = comb ss
  comb (Comb l x r : ss) = add x (comb (l:r:ss))

member :: Ord a => a -> Set a -> Bool
member x Nil  = False
member x (Comb l y r)
  | x < y     = member x l
  | x == y    = True
  | otherwise = member x r

isEmpty :: Set a -> Bool
isEmpty Nil = True
isEmpty _   = False

--

instance (Arbitrary a, Ord a) => Arbitrary (Set a) where
  arbitrary =
    do xs <- arbitrary
       return (set xs)
   where
    set [] = Nil
    set (x:xs) = Comb (set smaller) x (set larger)
     where
      smaller = [y | y <- xs, y < x]
      larger  = [y | y <- xs, y > x]

-- set invariant      
inv :: Set Int -> Bool
inv Nil          = True
inv (Comb l x r) = l <. x && x .< r && inv l && inv r
 where
  Nil        <. x = True
  Comb l y r <. x = y < x
  
  x .< Nil        = True
  x .< Comb l y r = x < y
  
-- set contents     
conts :: Set Int -> [Int]
conts Nil          = []
conts (Comb l x r) = conts l ++ [x] ++ conts r

-- the rest stays the same!
-}

---------------------------------------------------------------------
